home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / filemtch.scm < prev    next >
Text File  |  1995-10-21  |  4KB  |  94 lines
  1. ;;; Code for processing file names with regular expressions.
  2.  
  3. ;;; Copyright (c) 1994 by David Albertz (dalbertz@clark.lcs.mit.edu).
  4. ;;; Copyright (c) 1994 by Olin Shivers   (shivers@clark.lcs.mit.edu).
  5.  
  6. ;;; This code is freely available for use by anyone for any purpose,
  7. ;;; so long as you don't charge money for it, remove this notice, or
  8. ;;; hold us liable for any results of its use.  --enjoy.
  9.  
  10. ;;; Usage:    (file-match root dots? . pattern-list)
  11. ;;;                 root      Search starts from here. Usefully "." (cwd)
  12. ;;;                 dots? => if true, dot files will be matched.
  13. ;;;                          if false, dot files will not be matched.
  14. ;;;                 pattern-list := a list of regular expressions or predicates
  15. ;;;                                 Each member of the list corresponds
  16. ;;;                                 to one or more levels in a directory.
  17. ;;;                                 (A member with embedded "/" characters
  18. ;;;                                  corresponds to multiple levels.)
  19. ;;;                                 Example: ("foo" "bar" "\\.c$")
  20. ;;;                                     means match files that end in ".c"
  21. ;;;                                     if they reside in a directory with
  22. ;;;                                     a name that contains "bar", which
  23. ;;;                                     itself must reside in a directory
  24. ;;;                                     with a name that contains "foo".
  25. ;;;                                  If a member in the list is a predicate,
  26. ;;;                                  the predicate must be a procedure of
  27. ;;;                                  one argument.  This procedure is applied
  28. ;;;                                  to the file name being processed. If it
  29. ;;;                                  returns true, then the file is considered
  30. ;;;                                  a match.
  31.  
  32. ;;; Return:    list of matching file names (strings)
  33. ;;;             The matcher never considers "." or "..".
  34.  
  35. ;;; Subtle point:
  36. ;;;   If a file-match predicate raises an error condition, it is caught by
  37. ;;;   FILE-MATCH, and the file under consideration is not matched. This
  38. ;;;   means that (file-match "." #f file-directory?) doesn't error out
  39. ;;;   if you happen to run it in a directory containing a dangling symlink
  40. ;;;   when FILE-DIRECTORY? is applied to the bogus symlink.
  41.  
  42. (define (file-match root dot-files? . patterns)
  43.   (let ((patterns (apply append (map split-pat patterns))))
  44.     (let recur ((root root)
  45.         (patterns patterns))
  46.       (if (pair? patterns)
  47.       (let* ((pattern  (car patterns))
  48.          (patterns (cdr patterns))
  49.          (dir (file-name-as-directory root))
  50.          (matcher (cond ((string? pattern)
  51.                  (let ((re (make-regexp pattern)))
  52.                    (lambda (f) (regexp-exec re f))))
  53.  
  54.                 ;; This arm makes a file-matcher using
  55.                 ;; predicate PATTERN. If PATTERN signals
  56.                 ;; an error condition while it is being
  57.                 ;; run, our matcher catches it and returns
  58.                 ;; #f.
  59.                 ((procedure? pattern)
  60.                  (lambda (f)
  61.                    (call-with-current-continuation
  62.                     (lambda (abort)
  63.                       (with-handler (lambda (condition more)
  64.                               (if (error? condition)
  65.                               (abort #f)
  66.                               (more)))
  67.                         (lambda ()
  68.                       (pattern (string-append dir f))))))))
  69.  
  70.                 (else
  71.                  (error "Bad file-match pattern" pattern))))
  72.  
  73.          (candidates (maybe-directory-files root dot-files?))
  74.          (winners (filter matcher candidates)))
  75.         (apply append (map (lambda (fn) (recur (string-append dir fn)
  76.                            patterns))
  77.                    winners)))
  78.  
  79.       ;; All done
  80.       (cons root '())))))
  81.  
  82.  
  83. ;;; Split the pattern at the /'s. Slashes are assumed to *separate* 
  84. ;;; subpatterns, not terminate them.
  85.  
  86. (define (split-pat pat)
  87.   (if (procedure? pat) (list pat)
  88.       (let lp ((i (string-length pat))
  89.            (ans '()))
  90.     (cond ((rindex pat #\/ i) =>
  91.            (lambda (j) (lp (cons (substring pat (+ j 1) i) ans) j)))
  92.           (else
  93.            (cons (substring pat 0 i) ans))))))
  94.